home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / yerk / mps231ss.hqx / Mops source / System source / extras < prev    next >
Text File  |  1992-09-12  |  2KB  |  51 lines
  1. \    ========  Extensions to control structures  ========
  2.  
  3. \ Here is another keyed CASE.  Each test value or range is compiled into
  4. \ a pair of 2-byte entries in a table.  Compilation is turned off and on
  5. \ while getting the test values, which are evaluated at compile time.  This
  6. \ is slightly less flexible than Eaker's CASE, but is faster and more
  7. \ compact.  It is also adequate for the majority of keyed case needs.
  8. \ When you want a positional case, SELECT{ is still the best.
  9.  
  10. :code (CASE)        \ ( n -- )
  11.     loc
  12.     POP    D0    ; Test value to D0
  13.     MOVE    (A7),A0    ; A0 -> rtn addr
  14.     MOVE    A0,A1
  15.     ADD.W    (A1),A1    ; Case table addr to A1
  16.     ADD.W    2(A0),A0    ; A0 -> byte after case table
  17.     MOVE    A0,(A7)    ; Replace rtn addr for exit at 
  18.             ;  stub end
  19.     MOVE.W    (A1)+,D1    ; # entries in table to D1 (lo)
  20.     SUBQ.W    #1,D1    ; Set up for loop
  21.  
  22. loop    CMP.W    (A1)+,D0    ; Test against lo value in table
  23.     BGE.S    tryhi    ; OK - go and try the high value
  24.     ADDQ    #4,A1    ; No - skip hi val and stub offset
  25. looptst    DBRA    D1,loop    ; loop
  26.     PUSH    D0    ; Fell thru - push test value 
  27.             ;  again
  28.     BRA.S    goto    ;  and goto default.
  29.  
  30. tryhi    CMP.W    (A1)+,D0    ; Test against hi value in table
  31.     BLE.S    goto    ; OK - go to corresponding action 
  32.             ;  stub
  33.     ADDQ    #2,A1    ; No - increment table pointer
  34.     BRA.S    looptst    ;  and loop
  35.  
  36. goto    SUB.W    (A1),A1    ; Get action stub addr
  37.     JMP    (A1)    ; Go there
  38. ;code
  39.  
  40. window        DW    \ For display of source text during debugging
  41.  
  42. from EXTRASMOD 
  43. import{    sm bg l rl cl fm need +log -log  (create_log)  (write_log)
  44.     case[ ]=> ], range]=> range], default=> ]case
  45.     locate_src  addr>curs  redraw  use_module
  46.     1up 1dn 1lft 1rt  home end  defnup defndn selectdw
  47.     prof_str  }
  48.  
  49. :f CREATE_LOG    (create_log)  ;f
  50. :f WRITE_LOG    (write_log)   ;f
  51.